home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / jdbtree.com / JDBTREE.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-06-01  |  3.6 KB  |  134 lines
  1. Program JDBtree_Example;
  2.  
  3. Uses Crt;
  4.  
  5. type String_10 = String[10];
  6.      Branch=^Treenode;
  7.      Treenode = record
  8.        Word : String_10;
  9.        count : integer;
  10.        Left,Right : Branch
  11.      end; {TreeNode}
  12.  
  13. Var Root : Branch;
  14.     Words : Text;
  15.     flag : char;  {End of file flag}
  16.  
  17. {--------------------------------------------------------------------
  18.    BuildTree - Create the ROOT of the tree.
  19.  
  20.    The very first AttachNode in this procedure establishes the ROOT.
  21.    This procedure contains the loop to read until EOF.
  22.  
  23. --------------------------------------------------------------------}
  24. Procedure BuildTree(var Words : Text;
  25.                     var Root : Branch);
  26.  
  27. var Nextword : String_10;
  28.     Ancestor : Branch;
  29.  
  30. {--------------------------------------------------------------------
  31.    AttachNode - Connect New Node to tree.
  32.  
  33.    Create a NEW dynamic variable and set Ancestor to point to it.
  34.    Word becomes equal to Nextword.
  35.    Count is set to 1. This is the first occurance of the word.
  36.    Left and Right are set to nil.
  37.  
  38.    NOTE: This Procedure is only called for two reasons -
  39.  
  40.          1. It is establishing the ROOT.
  41.          2. If Ancestor is nil during PutInTree.
  42.  
  43. --------------------------------------------------------------------}
  44. Procedure AttachNode(Nextword :String_10;
  45.                      Var Ancestor : Branch);
  46. begin {AttachNode}
  47.   New(Ancestor);
  48.   with Ancestor^ do
  49.      begin
  50.         word := Nextword;
  51.         Count := 1;
  52.         Left := nil; Right := nil
  53.      end
  54. end; {AttachNode}
  55. {--------------------------------------------------------------------
  56.    PutInTree - Process a Record.
  57.  
  58.    This routine decides where in the tree the node belongs.
  59.    Notice the comparison statements.
  60.  
  61. --------------------------------------------------------------------}
  62. Procedure PutInTree (Nextword : String_10;
  63.                     var Ancestor : Branch);
  64.  
  65. begin {PutInTree}
  66.    if Ancestor = nil then
  67.       AttachNode(Nextword, Ancestor)
  68.    else if Nextword = Ancestor^.word then
  69.         Ancestor^.count := Ancestor^.count +1
  70.    else if Nextword < Ancestor^.word then
  71.         PutInTree(Nextword, Ancestor^.Left)
  72.    else PutInTree(Nextword, Ancestor^.Right)
  73. end; {PutInTree}
  74.  
  75. begin {BuildTree}
  76.   assign(Words, 'WORDS.DAT');
  77.   reset(Words);
  78.   Readln(Words, Nextword);
  79.   AttachNode(Nextword, Root);
  80.   while not EOF(Words) do
  81.     begin
  82.       readln(Words, Nextword);
  83.       Ancestor := Root;
  84.       PutInTree(Nextword, Ancestor);
  85.     end;
  86.   Close(Words);
  87. end;  {BuildTree}
  88.  
  89. Procedure Traverse(Root : Branch);
  90.  
  91. begin {Traverse}
  92.   if Root <> nil then
  93.      begin
  94.        Traverse(Root^.Left);
  95.        Write(Root^.Word,'     ');
  96.        Writeln(Root^.Count);
  97.        Traverse(Root^.Right);
  98.      end;
  99. end; {Traverse}
  100.  
  101. Procedure BBS_AD;
  102.    const filler=('          ');
  103.  
  104.    begin {BBS_AD}
  105.    Clrscr;
  106.    Writeln(filler,'           If you like this');
  107.    Writeln;
  108.    Writeln(filler,'                - Call -');
  109.    Writeln;
  110.    Writeln(filler,'  Polysyncronism BBS (312) 358-5104');
  111.    Writeln(filler,'8 Data Bits - Parity None - 1 Stop Bit');
  112.    Writeln(filler,'   100 Megabytes of online storage');
  113.    Writeln(filler,'           300:1200:2400 baud');
  114.    Writeln(filler,'              Open 24hrs');
  115.    Writeln(filler,'          Sysop: Jeff Darling');
  116.    Writeln(filler,'       Especially for Programmers.');
  117.    end; {BBS_AD}
  118.  
  119. begin {MAIN}
  120. Flag := 'Y';
  121. While Upcase(Flag) <> 'N' do
  122. begin
  123. ClrScr;
  124. BuildTree(Words,Root);
  125. Writeln('Word':1,'Ocurrences':15);
  126. Writeln('~~~~     ~~~~~~~~~~');
  127. Traverse(root);
  128. Writeln;
  129. Write('Run this program again? (y/n) ');readln(flag);
  130. end;
  131. BBS_Ad;
  132. end. {MAIN}
  133.  
  134.